home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / gjr / cmplrtst.lha / close2.scm < prev    next >
Encoding:
Text File  |  1990-03-27  |  933 b   |  47 lines
  1. ;;; -*- Scheme -*-
  2.  
  3. (declare (usual-integrations))
  4.  
  5. #|
  6. Description:
  7.  
  8. This code tests closing over procedures.
  9. &make-object and &object-ref are not integrated, so util1 and
  10. util2 must be closed over them, and therefore export1 and export2
  11. must be closed.
  12.  
  13. Usage:
  14.  
  15. (export1 x y) = (cons x (object-datum y))
  16. (export2 x y) = (cons (object-datum x) y)
  17.  
  18. Thus
  19.  
  20. (export1 x y) = (export2 x y) = (cons x y) 
  21. if x and y are fixnums.
  22.  
  23. Make sure that you do (gc-flip) twice after running this code,
  24. to make sure that the gc can handle closures.
  25.  
  26. |#
  27.  
  28. (define export1)
  29. (define export2)
  30.  
  31. (let ((&make-object (make-primitive-procedure '&MAKE-OBJECT 2))
  32.       (&object-ref (make-primitive-procedure 'SYSTEM-MEMORY-REF 2)))
  33.  
  34.   (define (util1 x)
  35.     (&make-object #x1a
  36.           (&object-ref x 0)))
  37.  
  38.   (define (util2 x)
  39.     (util1 (make-cell x)))
  40.  
  41.   (set! export1
  42.     (lambda (x y)
  43.       (cons x (util2 y))))
  44.  
  45.   (set! export2
  46.     (lambda (x y)
  47.       (cons (util2 x) y))))